home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr16.lha / excl-low.lisp < prev    next >
Lisp/Scheme  |  1992-09-16  |  4KB  |  137 lines
  1. ;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;; 
  27. ;;; This is the EXCL (Franz) lisp version of the file portable-low.
  28. ;;; 
  29. ;;; This is for version 1.1.2.  Many of the special symbols now in the lisp
  30. ;;; package (e.g. lisp::pointer-to-fixnum) will be in some other package in
  31. ;;; a later release so this will need to be changed.
  32. ;;; 
  33.  
  34. (in-package 'pcl)
  35.  
  36. (defmacro without-interrupts (&body body)
  37.   `(let ((outer-interrupts excl::*without-interrupts*)
  38.      (excl::*without-interrupts* 0))
  39.      (macrolet ((interrupts-on  ()
  40.           '(unless outer-interrupts
  41.              (setq excl::*without-interrupts* nil)))
  42.         (interrupts-off ()
  43.           '(setq excl::*without-interrupts* 0)))
  44.        ,.body)))
  45.  
  46. (eval-when (compile load eval)
  47.   (unless (fboundp 'excl::sy_hash)
  48.     (setf (symbol-function 'excl::sy_hash)
  49.       (symbol-function 'excl::_sy_hash-value)))
  50.   )
  51.  
  52. (defmacro memq (item list)
  53.   (let ((list-var (gensym))
  54.     (item-var (gensym)))
  55.     `(prog ((,list-var ,list)
  56.         (,item-var ,item))
  57.     start
  58.        (cond ((null ,list-var)
  59.           (return nil))
  60.          ((eq (car ,list-var) ,item-var)
  61.           (return ,list-var))
  62.          (t
  63.           (pop ,list-var)
  64.           (go start))))))
  65.  
  66. (defun std-instance-p (x)
  67.   (and (excl::structurep x)
  68.        (locally
  69.      (declare #.*optimize-speed*)
  70.      (eq (svref x 0) 'std-instance))))
  71.  
  72. (excl::defcmacro std-instance-p (x)
  73.   (once-only (x)
  74.     `(and (excl::structurep ,x)
  75.       (locally
  76.         (declare #.*optimize-speed*)
  77.         (eq (svref ,x 0) 'std-instance)))))
  78.  
  79. (excl::defcmacro fast-method-call-p (x)
  80.   (once-only (x)
  81.     `(and (excl::structurep ,x)
  82.       (locally
  83.         (declare #.*optimize-speed*)
  84.         (eq (svref ,x 0) 'fast-method-call)))))
  85.  
  86. (defmacro %std-instance-wrapper (x)
  87.   `(svref ,x 1))
  88.  
  89. (defmacro %std-instance-slots (x)
  90.   `(svref ,x 2))
  91.  
  92. (defun printing-random-thing-internal (thing stream)
  93.   (format stream "~O" (excl::pointer-to-fixnum thing)))
  94.  
  95. #-vax
  96. (defun set-function-name-1 (fn new-name ignore)
  97.   (declare (ignore ignore))
  98.   (cond ((excl::function-object-p fn)
  99.      (setf (excl::fn_symdef fn) new-name))
  100.     (t nil))
  101.   fn)
  102.  
  103. (defun function-arglist (f)
  104.   (excl::arglist f))
  105.  
  106. (defun symbol-append (sym1 sym2 &optional (package *package*))
  107.    ;; This is a version of symbol-append from macros.cl
  108.    ;; It insures that all created symbols are of one case and that
  109.    ;; case is the current prefered case.
  110.    ;; This special version of symbol-append is not necessary if all you
  111.    ;; want to do is compile and run pcl in a case-insensitive-upper 
  112.    ;; version of cl.  
  113.    ;;
  114.    (let ((string (string-append sym1 sym2)))
  115.       (case excl::*current-case-mode*
  116.      ((:case-insensitive-lower :case-sensitive-lower)
  117.       (setq string (string-downcase string)))
  118.      ((:case-insensitive-upper :case-sensitive-upper)
  119.       (setq string (string-upcase string))))
  120.       (intern string package)))
  121.  
  122. ;;; Define inspector hooks for PCL object instances.
  123.  
  124. (defun (:property pcl::std-instance :inspector-function) (object)
  125.   (let ((class (class-of object)))
  126.     (cons (inspect::make-field-def "class" #'class-of :lisp)
  127.       (mapcar #'(lambda (slot)
  128.               (inspect::make-field-def
  129.                (string (slot-definition-name slot))
  130.                #'(lambda (x)
  131.                (slot-value-using-class class x slot))
  132.                :lisp))
  133.           (slots-to-inspect class object)))))
  134.  
  135. (defun (:property pcl::std-instance :inspector-type-function) (x)
  136.   (class-name (class-of x)))
  137.